home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / SIOD / Port.scm < prev    next >
Encoding:
Text File  |  1993-09-24  |  2.1 KB  |  67 lines
  1. (define (file-length x)
  2.         (let ((a (open-input-file x))
  3.               (b nil))
  4.              (set-file-position! a 0 2)
  5.              (set! b (get-file-position a))
  6.              (close-port a)
  7.              b))
  8.  
  9. (define (open-binary-input-file x) (open-port x "rb" 1))
  10.  
  11. (define (open-binary-output-file x) (open-port x "wb" 1))
  12.  
  13. (define (open-input-file x) (open-port x "r" 1))
  14.  
  15. (define (open-output-file x) (open-port x "w" 1))
  16.  
  17. (define (open-extend-file x) (open-port x "a" 1))
  18.  
  19. (define (current-input-port) (fluid input-port))
  20.  
  21. (define (current-output-port) (fluid output-port))
  22.  
  23. (define (newline . x) (display #\newline (car x)))
  24.  
  25. (define (page . x) (display #\page (car x)))
  26.  
  27. (define (call-with-input-file x y)
  28.         (let* ((in (open-input-file x))
  29.                (res (y in)))
  30.               (close-input-port in)
  31.               res))
  32.  
  33. (define (call-with-output-file x y)
  34.         (let* ((in (open-output-file x))
  35.                (res (y in)))
  36.               (close-output-port in)
  37.               res))
  38.  
  39. (define (with-input-from-file x y)
  40.         (letrec ((old-in (fluid input-port))
  41.                  (new-in (open-port x "r" -1))
  42.                  (p (lambda () (close-input-port new-in)
  43.                                (set! (fluid input-port) old-in)))
  44.                  (res nil))
  45.                 (set! (fluid input-port) new-in)
  46.                 (call-on-reset p)
  47.                 (set! res (y))
  48.                 (close-input-port (fluid input-port))
  49.                 (set! (fluid input-port) old-in)
  50.                 (uncall-on-reset p)
  51.                 res))
  52.  
  53. (define (with-output-to-file x y)
  54.         (letrec ((old-out (fluid output-port))
  55.                  (new-out (open-port x "w" -1))
  56.                  (p (lambda () (close-output-port new-out)
  57.                                (set! (fluid output-port) old-out)))
  58.                  (res nil))
  59.                 (set! (fluid output-port) new-out)
  60.                 (call-on-reset p)
  61.                 (set! res (y))
  62.                 (close-output-port (fluid output-port))
  63.                 (set! (fluid output-port) old-out)
  64.                 (uncall-on-reset p)
  65.                 res))
  66.  
  67.